PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/dos/pascal/dgsay.exe/DGINIT.PAS

Pascal/Delphi Source File | 1989-06-29 | 27.5 KB | 972 lines

{
 ╔═════════════════════════════════════════════════════════════════════════╗
 ║                                                                         ║
 ║        TITLE :      DGINIT.TPU,  Version 8906.01                        ║
 ║      PURPOSE :      Various wheels.  Don't reinvent.                    ║
 ║       AUTHOR :      David Gerrold, CompuServe ID:  70307,544            ║
 ║  _____________________________________________________________________  ║
 ║                                                                         ║
 ║  This is not public domain software.  This is shareware.                ║
 ║  This software is copyright 1989, by David Gerrold.                     ║
 ║                                                                         ║
 ║        The Brass Cannon Corporation                                     ║
 ║        9420 Reseda Blvd., #804                                          ║
 ║        Northridge, CA 91324-2932.                                       ║
 ║                                                                         ║
 ║  If you find this code useful, a donation of $25 is requested --        ║
 ║  not to me, but to the AIDS Project Los Angeles.  Donations may         ║
 ║  be forwarded via the Brass Cannon address.  Thank you.                 ║
 ║                                                                         ║
 ╚═════════════════════════════════════════════════════════════════════════╝
                                                                            }
{ ========================================================================= }
{  Compiler Directives :                                                    }
{ ========================================================================= }

{$R-}    {Range checking off}
{$B+}    {Boolean complete evaluation on}
{$S+}    {Stack checking on}
{$I+}    {I/O checking on}
{$N+,E+} {Simulate numeric coprocessor}
{$M 65500,16384,655360} {Turbo 3 default stack and heap}
{$V-}    {Variable range checking off}

{ ========================================================================= }
{ ========================================================================= }

UNIT DGinit;
{ includes time and date functions }

{ ========================================================================= }
INTERFACE
{ ========================================================================= }

USES
  Dos,                                           { TP5.5 unit }
  TpDos,                                         { Turbo Professional unit }
  TpCrt,                                         { Turbo Professional unit }
  TpString,                                      { Turbo Professional unit }
  TpWindow;                                      { Turbo Professional unit }

{ ========================================================================= }

TYPE
  String2    = string [2];
  String3    = string [3];
  String6    = string [6];
  String12   = string [12];
  String25   = string [25];
  String80   = string [80];

  LocOb = Object
    Row, Col : byte;
    Procedure AcceptLoc (R, C : byte);
    Procedure ReportLoc (Var R, C : byte);
    Procedure GotoRC;
  end;

  TimeOb = Object
    Hour,
    Minute,
    Second,
    Sec100 : word;

    Function PcTime : String12;                  { '10:36:09 pm' }
    Function ShortTime : String6;                { '9:07p' }
  end;

  DateOb = Object (TimeOb)
    Year,
    Month,
    Day,
    DayOfWeek : word;

    Function  LeapYear      : boolean;           { returns true if leap year }
    Function  ValidDate     : boolean;           { returns true if valid date }
    Function  GetDayOfWeek  : word;              { returns day of week }
    Function  DayOfTheWeek3 : String3;           { returns 'Tue' }
    Function  DayOfTheWeek  : String12;          { returns 'Tuesday' }

    Procedure GetToday;                          { put today's date in }
                                                 { DateOb variables }
    Procedure AcceptDate (Y, M, D : word);       { accept user variables }
    Procedure AdvanceDate;                       { advances date one day }

    Function  PcDate        : String12;          { ' 3-05-88' }
    Function  LogDate       : String12;          { ' 5-Mar-88' }
    Function  StarDate      : String12;          { '8803.05' }
    Function  FormalDate    : String25;          { 'March 5, 1988' }
    Function  AbbrevDate    : String25;          { 'Tue, 3-05-88' }
    Function  FullDate      : String25;          { 'Tuesday, March 5, 1988' }
    Function  TimeStamp     : String25;          { 'Tue, 12-23-86, 11:01p' }
  end;

CONST
    Yes = True;
    No  = False;
    On  = True;
    Off = False;

  SoundFlag   : Boolean = True;
  MusicFlag   : Boolean = True;
  ClickFlag   : Boolean = True;
  ClockFlag   : Boolean = False;

  SingleLine  = #218#192#191#217#196#179;
  DoubleLine  = #201#200#187#188#205#186;

  Blinking    : byte = 128;

  BlackBlack            = $00;
  BlueBlack             = $01;
  GreenBlack            = $02;
  CyanBlack             = $03;
  RedBlack              = $04;
  MagentaBlack          = $05;
  BrownBlack            = $06;
  LightGrayBlack        = $07;
  DarkGrayBlack         = $08;
  LightBlueBlack        = $09;
  LightGreenBlack       = $0A;
  LightCyanBlack        = $0B;
  LightRedBlack         = $0C;
  LightMagentaBlack     = $0D;
  YellowBlack           = $0E;
  WhiteBlack            = $0F;
  BlackBlue             = $10;
  BlueBlue              = $11;
  GreenBlue             = $12;
  CyanBlue              = $13;
  RedBlue               = $14;
  MagentaBlue           = $15;
  BrownBlue             = $16;
  LightGrayBlue         = $17;
  DarkGrayBlue          = $18;
  LightBlueBlue         = $19;
  LightGreenBlue        = $1A;
  LightCyanBlue         = $1B;
  LightRedBlue          = $1C;
  LightMagentaBlue      = $1D;
  YellowBlue            = $1E;
  WhiteBlue             = $1F;
  BlackGreen            = $20;
  BlueGreen             = $21;
  GreenGreen            = $22;
  CyanGreen             = $23;
  RedGreen              = $24;
  MagentaGreen          = $25;
  BrownGreen            = $26;
  LightGrayGreen        = $27;
  DarkGrayGreen         = $28;
  LightBlueGreen        = $29;
  LightGreenGreen       = $2A;
  LightCyanGreen        = $2B;
  LightRedGreen         = $2C;
  LightMagentaGreen     = $2D;
  YellowGreen           = $2E;
  WhiteGreen            = $2F;
  BlackCyan             = $30;
  BlueCyan              = $31;
  GreenCyan             = $32;
  CyanCyan              = $33;
  RedCyan               = $34;
  MagentaCyan           = $35;
  BrownCyan             = $36;
  LightGrayCyan         = $37;
  DarkGrayCyan          = $38;
  LightBlueCyan         = $39;
  LightGreenCyan        = $3A;
  LightCyanCyan         = $3B;
  LightRedCyan          = $3C;
  LightMagentaCyan      = $3D;
  YellowCyan            = $3E;
  WhiteCyan             = $3F;
  BlackRed              = $40;
  BlueRed               = $41;
  GreenRed              = $42;
  CyanRed               = $43;
  RedRed                = $44;
  MagentaRed            = $45;
  BrownRed              = $46;
  LightGrayRed          = $47;
  DarkGrayRed           = $48;
  LightBlueRed          = $49;
  LightGreenRed         = $4A;
  LightCyanRed          = $4B;
  LightRedRed           = $4C;
  LightMagentaRed       = $4D;
  YellowRed             = $4E;
  WhiteRed              = $4F;
  BlackMagenta          = $50;
  BlueMagenta           = $51;
  GreenMagenta          = $52;
  CyanMagenta           = $53;
  RedMagenta            = $54;
  MagentaMagenta        = $55;
  BrownMagenta          = $56;
  LightGrayMagenta      = $57;
  DarkGrayMagenta       = $58;
  LightBlueMagenta      = $59;
  LightGreenMagenta     = $5A;
  LightCyanMagenta      = $5B;
  LightRedMagenta       = $5C;
  LightMagentaMagenta   = $5D;
  YellowMagenta         = $5E;
  WhiteMagenta          = $5F;
  BlackBrown            = $60;
  BlueBrown             = $61;
  GreenBrown            = $62;
  CyanBrown             = $63;
  RedBrown              = $64;
  MagentaBrown          = $65;
  BrownBrown            = $66;
  LightGrayBrown        = $67;
  DarkGrayBrown         = $68;
  LightBlueBrown        = $69;
  LightGreenBrown       = $6A;
  LightCyanBrown        = $6B;
  LightRedBrown         = $6C;
  LightMagentaBrown     = $6D;
  YellowBrown           = $6E;
  WhiteBrown            = $6F;
  BlackLightGray        = $70;
  BlueLightGray         = $71;
  GreenLightGray        = $72;
  CyanLightGray         = $73;
  RedLightGray          = $74;
  MagentaLightGray      = $75;
  BrownLightGray        = $76;
  LightGrayLightGray    = $77;
  DarkGrayLightGray     = $78;
  LightBlueLightGray    = $79;
  LightGreenLightGray   = $7A;
  LightCyanLightGray    = $7B;
  LightRedLightGray     = $7C;
  LightMagentaLightGray = $7D;
  YellowLightGray       = $7E;
  WhiteLightGray        = $7F;

  DayName     : Array [0 .. 6] of String [9] =
                        ('Sunday', 'Monday', 'Tuesday', 'Wednesday',
                         'Thursday', 'Friday', 'Saturday');
  MonthName   : Array [1 .. 12] of String [9] =
                        ('January', 'February', 'March', 'April',
                         'May', 'June', 'July', 'August', 'September',
                         'October', 'November', 'December');
  MonthLength : Array [1 .. 12] of Byte =
                       (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);

  TimeUntilBlank : LongInt = 180000;             { approx 3 minutes }

  BackSpace       = #8;
  Tab             = #9;
  Enter           = #13;
  Esc             = #27;
  CtrlBackSpace   = #127;
  ShiftTab        = #143;

  ShiftHomeKey    = #177;
  ShiftUpArrow    = #178;
  ShiftPageUp     = #179;
  ShiftLeftArrow  = #180;
  ShiftRightArrow = #181;
  ShiftEndKey     = #182;
  ShiftDownArrow  = #183;
  ShiftPageDown   = #184;
  ShiftInsertKey  = #185;
  ShiftDeleteKey  = #186;

  F1         = #187;
  F2         = #188;
  F3         = #189;
  F4         = #190;
  F5         = #191;
  F6         = #192;
  F7         = #193;
  F8         = #194;
  F9         = #195;
  F10        = #196;

  HomeKey    = #199;
  UpArrow    = #200;
  PageUp     = #201;
  LeftArrow  = #203;
  RightArrow = #205;
  EndKey     = #207;
  DownArrow  = #208;
  PageDown   = #209;
  InsertKey  = #210;
  DeleteKey  = #211;

  ShiftF1    = #212;
  ShiftF2    = #213;
  ShiftF3    = #214;
  ShiftF4    = #215;
  ShiftF5    = #216;
  ShiftF6    = #217;
  ShiftF7    = #218;
  ShiftF8    = #219;
  ShiftF9    = #220;
  ShiftF10   = #221;

  CtrlF1     = #222;
  CtrlF2     = #223;
  CtrlF3     = #224;
  CtrlF4     = #225;
  CtrlF5     = #226;
  CtrlF6     = #227;
  CtrlF7     = #228;
  CtrlF8     = #229;
  CtrlF9     = #230;
  CtrlF10    = #231;

  AltF1      = #232;
  AltF2      = #233;
  AltF3      = #234;
  AltF4      = #235;
  AltF5      = #236;
  AltF6      = #237;
  AltF7      = #238;
  AltF8      = #239;
  AltF9      = #240;
  AltF10     = #241;

  CtrlLeftArrow   = #243;
  CtrlRightArrow  = #244;
  CtrlEndKey      = #245;
  CtrlPageDown    = #246;
  CtrlHomeKey     = #247;
  CtrlPageUp      = #248;        { Scancode-shift sees CtrlPageUp as ^D }
                                 { ReadChar translates it to #248 }

  CtrlShiftLeftArrow   = #249;
  CtrlShiftRightArrow  = #250;
  CtrlShiftEndKey      = #251;
  CtrlShiftPageDown    = #252;
  CtrlShiftHomeKey     = #253;
  CtrlShiftPageUp      = #254;

VAR
  RightShiftKey,
  LeftShiftKey,
  ShiftKey,
  ControlKey,
  AltKey,
  ScrlLock,
  NumLock,
  CapsLock,
  InsLock       : boolean;

  LogOnTime     : LongInt;                       { time program started }

{ ========================================================================= }

FUNCTION Max (Num1, Num2 : integer) : integer;

FUNCTION Min (Num1, Num2 : integer) : integer;

PROCEDURE SetBitTo1 (VAR B : byte;  Bit: byte);

PROCEDURE SetBitTo0 (VAR B : byte;  Bit: byte);

PROCEDURE Click;

PROCEDURE Beep;

PROCEDURE Wait;
{ waits for any keyboard activity }

PROCEDURE PauseWithPrompt (Prompt : string);
{ 'Press any key to continue. . . . ' }

PROCEDURE Pause;
{ Prompts:  'Press any key to continue. . . . ' }

PROCEDURE BlankLine (Row, Len, Attr : byte);
{ writes a blank line to screen }

FUNCTION  ExistAnyFile (FileName : String) : boolean;
{ does this file exist? }

PROCEDURE AddFileExt (FileName, Ext : string);
{ if no file extension, adds specified extension }

PROCEDURE ShowTime;
{ Puts a time string in the upper right corner of the screen }

PROCEDURE ShowToday;
{ Puts date and time in the upper right corner of the screen }

PROCEDURE ResetDate;
{ use for advancing date and resetting it after midnight }

FUNCTION  WaitingPatiently (TimeToWait : LongInt) : boolean;
{ If no key is pressed before time is up, function returns true. }

PROCEDURE DisposeNilWindow (VAR W : WindowPtr);
{ Disposes of window, returns WindowPtr to nil. }

PROCEDURE OpenProgram;
{ Saves existing Dos screen. }

PROCEDURE CloseProgram;
{ Returns to original Dos screen. }

{ ========================================================================= }
IMPLEMENTATION
{ ========================================================================= }

VAR
  SaveCursorLoc : LocOb;                         { location of cursor }

  SaveDosCursor : word;                          { cursor at start }
  SaveCBreak    : boolean;                       { Ctrl-C break at start }
  SaveDosScreen : PackedWindowPtr;               { screen at start }

  ExitSave      : pointer;                       { for ExitProc }

{ ========================================================================= }

FUNCTION Max (Num1, Num2 : integer) : integer;
Begin
If Num1 > Num2 Then Max := Num1 Else Max := Num2;
End;

{ ========================================================================= }

FUNCTION Min (Num1, Num2 : integer) : integer;
Begin
If Num1 < Num2 Then Min := Num1 Else Min := Num2;
End;

{ ========================================================================= }

PROCEDURE SetBitTo1 (VAR B : byte;  Bit: byte);
BEGIN
B := B or (1 shl Bit)
END;

{ ========================================================================= }

PROCEDURE SetBitTo0 (VAR B : byte;  Bit: byte);
BEGIN
B := B and not (1 shl Bit)
END;

{ ========================================================================= }

PROCEDURE Click;
BEGIN
  If ClickFlag then begin
    Sound (220);
    Delay (4);
    NoSound;
    end;
END;

{ ========================================================================= }

PROCEDURE Beep;
  Begin
  If SoundFlag Then
    Begin
    Sound (440);
    Delay (15);
    NoSound;
    End;
  End;

{ ========================================================================= }

PROCEDURE Wait;                                  { 8906.01 }
{ Waits for any keyboard activity.  }
{ Recognizes normal, control, & lock keys.  Flushes key if pressed.  }

VAR
  Ch             : char;
  SaveByte       : byte;
  KeyStates      : byte;
  KeyStateByte   : byte absolute $40:$17;

BEGIN
  SaveByte := KeyStateByte;                      { save lock keys }
  KeyStates := KeyStateByte;
  Repeat Until Keypressed or (KeyStates <> KeyStateByte);
  If KeyPressed then
    while Keypressed do Ch := ReadKey;           { flush buffer }

{ leave changed new states of alt, ctrl, shift keys }
  KeyStateByte := (KeyStateByte and $F) or (SaveByte and $F0);
END;

{ ========================================================================= }

PROCEDURE PauseWithPrompt (Prompt : string);
{
  Prints centered prompt, then waits for key to be pressed.
}

BEGIN
WriteLn;
FastWriteWindow (Prompt, WhereY, 40 - Trunc (Length (Prompt)/2), LightRed);
Wait;
END;

{ ========================================================================= }

PROCEDURE Pause;

BEGIN
PauseWithPrompt ('Press any key to continue.');
END;

{ ========================================================================= }

PROCEDURE BlankLine (Row, Len, Attr : Byte);

BEGIN
  FastWriteWindow (CharStr (' ', Len), Row, 1, Attr);
END;

{ ========================================================================= }

FUNCTION ExistAnyFile (FileName : String) : Boolean;

VAR
  SaveMode : Byte;

Begin
   SaveMode := FileMode;
   FileMode := 0;
   ExistAnyFile := ExistFile (FileName);
   FileMode := SaveMode;
End;

{ ========================================================================= }

PROCEDURE AddFileExt (FileName, Ext : string);

Begin
  If Pos ('.', FileName) = 0 Then FileName := FileName + '.' + Ext;
End;

{ ========================================================================= }

PROCEDURE LocOb.AcceptLoc (R, C : byte);

BEGIN
  Row := R;
  Col := C;
END;

{ ========================================================================= }

PROCEDURE LocOb.ReportLoc (Var R, C : byte);

BEGIN
  R := Row;
  C := Col;
END;

{ ========================================================================= }

PROCEDURE LocOb.GotoRC;

BEGIN
  Gotoxy (Col, Row);
END;

{ ========================================================================= }

FUNCTION ZeroFix (NumStr : String2) : String2;

BEGIN
  If NumStr [0] = #1 Then Insert ('0', NumStr, 1);
  ZeroFix := NumStr;
END;

{ ========================================================================= }

FUNCTION SpaceFix (NumStr : String2) : String2;

BEGIN
  If NumStr [0] = #1 Then Insert (' ', NumStr, 1);
  SpaceFix := NumStr;
END;

{ ========================================================================= }

FUNCTION TimeOb.PcTime : String12;
{ Returns a string showing the current time in this format: `10:36:09 pm'.  }

VAR
  AmPm : string [2];

BEGIN
  GetTime (Hour, Minute, Second, Sec100);

  Case Hour Of
    0           : Begin
                  AmPm := 'am';
                  Hour := 12;
                  End;
    1 .. 11     : AmPm := 'am';
    12          : AmPm := 'pm';
    13 .. 23    : Begin
                  AmPm := 'pm';
                  Hour := Hour - 12;
                  End;
    End;  { Case Hour Of }

    PCtime := SpaceFix (Long2Str (Hour)) + ':' +
              ZeroFix (Long2Str (Minute)) + ':' +
              ZeroFix (Long2Str (Second)) + ' ' + AmPm;
End;

{ ========================================================================= }

FUNCTION TimeOb.ShortTime : String6;
{ Returns time in format:  '9:07p' }

VAR
  TempStr : String12;
  Len     : byte absolute TempStr;

BEGIN
  TempStr := PcTime;
  Delete (TempStr, Len, 1);
  Delete (TempStr, Len - 4, 4);
  ShortTime := TempStr;
END;

{ ========================================================================= }

FUNCTION DateOb.LeapYear : boolean;
{ Returns true if year is leap year }

BEGIN
  LeapYear := ((Year mod 4 = 0)
                  and
              (Year mod 100 <> 0))
                   or
              (Year mod 400 = 0);
END;

{ ========================================================================= }

FUNCTION DateOb.ValidDate: boolean;
{ Returns true if year is leap year }

BEGIN
  ValidDate := (Month mod 12 <= 11)
                 and
               (Day <= (MonthLength [Month] + ord (LeapYear)));
END;

{ ========================================================================= }

FUNCTION DateOb.GetDayOfWeek : Word;
{ Gets the day of the week as a number. }

VAR
  Y,
  Loop : Word;

BEGIN
  MonthLength [2] := 28 + Ord (LeapYear);        { How long is Feb? }

{ Calculate what day is today, allowing for all previous leap years.      }
  Y := Year MOD 7 + Pred (Day) - ord (LeapYear) +
       Year DIV 4 - Year DIV 100 + Year DIV 400;
  For Loop := 1 to Pred (Month) do
    Y := Y + MonthLength [Loop];
  GetDayOfWeek := Y mod 7;
END;

{ ========================================================================= }

FUNCTION DateOb.DayOfTheWeek3 : String3;
{ Returns:  `Tue' }

BEGIN
  DayOfTheWeek3 := Copy (DayName [DayOfWeek], 1, 3);
END;

{ ========================================================================= }

FUNCTION DateOb.DayOfTheWeek : String12;
{ Returns:  `Tuesday' }

BEGIN
  DayOfTheWeek := DayName [DayOfWeek];
END;

{ ========================================================================= }

PROCEDURE DateOb.GetToday;

BEGIN
  GetDate (Year, Month, Day, DayOfWeek);
END;

{ ========================================================================= }

PROCEDURE DateOb.AcceptDate (Y, M, D : word);

BEGIN
  Year := Y;
  Month := M;
  Day := D;
  DayOfWeek := GetDayOfWeek;
END;

{ ========================================================================= }

PROCEDURE DateOb.AdvanceDate;
{ Advances date by one. }

VAR
  Loop      : Word;

BEGIN
  MonthLength [2] := 28 + Ord (LeapYear);        { How long is Feb? }
  inc (DayOfWeek);
  DayOfWeek := DayOfWeek mod 7;
  inc (Day);
  If Day > MonthLength [Month] then begin
    Day := 1;
    inc (Month);
    If Month > 12 then begin
      Month := 1;
      inc (Year);
      end;
    end;
END;

{ ========================================================================= }

FUNCTION DateOb.PcDate : String12;
{ Returns Date in PC format:  ' 3-05-88' }

BEGIN
  If not ValidDate then GetToday;
  PCdate := SpaceFix (Long2Str (Month)) + '-' +
            ZeroFix (Long2Str (Day)) + '-' +
            ZeroFix (Long2Str (Year mod 100));
END;

{ ========================================================================= }

FUNCTION DateOb.LogDate : String12;
{ Returns Date in Log format:  ' 5-Mar-88' }

BEGIN
  If not ValidDate then GetToday;
  LogDate := SpaceFix (Long2Str (Day)) + '-' +
             Copy (MonthName [Month], 1, 3) + '-' +
             ZeroFix (Long2Str (Year mod 100));
END;

{ ========================================================================= }

FUNCTION DateOb.StarDate : String12;
{ Returns Date in StarDate format:  '8803.05' }

BEGIN
  If not ValidDate then GetToday;
  StarDate := ZeroFix (Long2Str (Year mod 100)) +
              ZeroFix (Long2Str (Month)) + '.' +
              ZeroFix (Long2Str (Day));
END;

{ ========================================================================= }

FUNCTION DateOb.FormalDate : String25;
{ Returns Date:  'March 5, 1988' }

BEGIN
  If not ValidDate then GetToday;
  FormalDate := MonthName [Month] + ' ' +
                Long2Str (Day) + ', ' +
                Long2Str (Year);
END;

{ ========================================================================= }

FUNCTION DateOb.AbbrevDate: String25;
{ Returns Date:  'March 5, 1988' }

BEGIN
  If not ValidDate then GetToday;
  AbbrevDate := DayOfTheWeek3 + ', ' + Trim (PcDate);
END;

{ ========================================================================= }

FUNCTION DateOb.FullDate: String25;
{ Returns Date:  'March 5, 1988' }

BEGIN
  If not ValidDate then GetToday;
  FullDate := DayOfTheWeek + ', ' +
              MonthName [Month] + ' ' +
              Long2Str (Day) + ', ' +
              Long2Str (Year);
END;

{ ========================================================================= }

FUNCTION DateOb.TimeStamp : String25;
{ Returns:  `Tue, 12-23-86, 11:01p' }

BEGIN
  TimeStamp := AbbrevDate + ', ' + ShortTime;
END;

{ ========================================================================= }

PROCEDURE ShowTime;
{ Puts a time string in the upper right corner of the screen }

VAR
  TimeStamp : TimeOb;

BEGIN
  FastWrite (TimeStamp.PcTime, 1, 70, 10);
END;

{ ========================================================================= }

PROCEDURE ShowToday;
{ Puts time and date in the upper right corner of the screen }

VAR
  DateStamp : DateOb;

BEGIN
  FastWrite (DateStamp.AbbrevDate, 1, 68, 10);
  FastWrite (DateStamp.PcTime, 2, 68, 10);
END;

{ ========================================================================= }

PROCEDURE ResetDate;

VAR
  TimeStamp : DateOb;

BEGIN
With TimeStamp do begin
  GetToday;
  AdvanceDate;
  SetDate (Year, Month, Day);
  LogOnTime := TimeMs;                           { get new LogOnTime }
  end;
END;

{ ========================================================================= }

FUNCTION WaitingPatiently (TimeToWait : LongInt) : boolean;
{ Returns false if key is pressed before time is up. }
{ Will display date and time in upper right corner if ClockFlag is true. }

VAR
  Start, Stop  : LongInt;
  KeyStates    : byte;
  KeyStateByte : byte absolute $40:$17;

BEGIN
  WaitingPatiently := false;
  If TimeMs < LogOnTime Then ResetDate;
  Start := TimeMs;
  KeyStates := KeyStateByte;
  Repeat
    If ClockFlag then ShowToday;
    Stop := TimeMs;
    If Stop < Start then begin
      ResetDate;
      Start := TimeMs;
      End;
    If KeyStates <> KeyStateByte then begin
      KeyStates := KeyStateByte;
      Start := TimeMs;
      end;
    If KeyPressed then exit;
  Until
    (Stop - Start) > TimeToWait;
  WaitingPatiently := true;
END;

{ ========================================================================= }

PROCEDURE DisposeNilWindow (VAR W : WindowPtr);
{
  Erases window, disposes it, resets WindowPtr to nil.
}
BEGIN
If W <> Nil then
  If SetTopWindow (W) then begin
        W := EraseTopWindow;
      DisposeWindow (W);
      W := Nil;
        end;
END;

{ ========================================================================= }

PROCEDURE OpenProgram;

BEGIN
  SaveDosScreen := PackWindow (1, 1, 80, 25);
  HiddenCursor;
  ClrScr;
END;

{ ========================================================================= }

PROCEDURE CloseProgram;

BEGIN
  DispPackedWindow (SaveDosScreen);              { restore underlying screen }
  DisposePackedWindow (SaveDosScreen);           { dispose where it's saved }
  SaveCursorLoc.GotoRC;                          { restore cursor loc }
END;

{ ========================================================================= }

{$F+} PROCEDURE ExitProgram; {$F-}


BEGIN
  NormVideo;                                     { restore original attr }
  SetCursorSize (hi (SaveDosCursor),
                 lo (SaveDosCursor));            { restore cursor }

  SetCBreak (SaveCBreak);                        { restore Ctrl-C }
  ExitProc := ExitSave;                          { Say Goodnight Gracie }
END;

{ ========================================================================= }
{  Initialization :                                                         }
{ ========================================================================= }

BEGIN
  LogOnTime    := TimeMs;                        { what time did we start? }

  GetCBreak (SaveCBreak);                        { get Ctrl-C status }
  SetCBreak (false);                             { turn Ctrl-C off }
  CheckBreak := false;                           { turn off Ctrl-Break }

  SaveCursorLoc.AcceptLoc
    (pred (WhereY), WhereX);                     { save cursor location }
  SaveDosCursor := CursorTypeSL;                 { Dos cursor is what? }
  MapColors     := (CurrentDisplay = MonoHerc);  { B/W display? }
  TextAttr      := MapColor (YellowBlack);       { set attr }

  ExitSave := ExitProc;                          { set up exit proc }
  ExitProc := @ExitProgram;                      { get pointer }
END.

{ ========================================================================= }
{ ========================================================================= }